unit TunnelThrd;

interface

uses
  Classes, SyncObjs, SysUtils, windows,
  blcksock, synsock, synautil;

type
  TTunnelThread = class;
  PTunnelItem = ^TTunnelItem;
  TTunnelItem = record
    name, lport, dhost, dport, password: string;
    Thread: TTunnelThread;
  end;
  TTunnelState=(tsBinding, tsBindFail, tsListenning, tsConnected);
  TTunnelThread = class(TThread)
  protected
    Item: PTunnelItem;
    fpassword: String;
    procedure Execute; override;
    function RelayTCP(const fsock, dsock: TTCPBlockSocket): boolean;
  public
    state: TTunnelState;
    LastError, ReadCount, WriteCount: Integer;
    constructor Create(Item: PTunnelItem);
  end;

implementation

{==============================================================================}

constructor TTunnelThread.create(Item: PTunnelItem);
begin
  Item.Thread := Self;
  Self.Item := item;
  fpassword :=  item.password;
  FreeOnTerminate := true;
  inherited create(false);
end;

procedure TTunnelThread.Execute;
var
  lsock, fsock, dsock: TTCPBlockSocket;
  csock: TSocket;
begin
  lsock := TTCPBlockSocket.Create;
  try
    state := tsBinding;
    lsock.bind('0.0.0.0', item.lport);
    if lsock.LastError <> 0 then
    begin
      state := tsBindFail;
      Exit;
    end;
    lsock.setLinger(true,10);
    state := tsListenning;
    lsock.listen;
    repeat
      state := tsListenning;
      if terminated then
        break;
      if lsock.canread(1000) then
      begin
        state := tsConnected;
        csock := lsock.accept;
        if lsock.lastError = 0 then
        begin
          fsock := TTCPBlockSocket.create;
          dsock := TTCPBlockSocket.create;
          try
            fsock.Socket := csock;
            dsock.Connect(item.dhost, item.dport);
            if dsock.LastError = 0 then
              RelayTCP(fsock, dsock);
            if fsock.LastError = 0 then
              LastError := fsock.lastError
            else if dsock.LastError = 0 then
              LastError := dsock.lastError;
          finally
            fsock.free;
            dsock.free;
          end;
        end
        else
          LastError := lsock.lastError;
      end;
    until false;
  finally
    lsock.free;
    Item.Thread := nil;
  end;
end;

const
  timeout = 120000;
  
function TTunnelThread.RelayTCP(const fsock, dsock: TTCPBlockSocket): boolean;
var
  n: integer;
  buf: string;
  ql, rl: TList;
  fgsock, dgsock: TTCPBlockSocket;
  FDSet: TFDSet;
  FDSetSave: TFDSet;
  TimeVal: PTimeVal;
  TimeV: TTimeVal;
begin
  result := false;
  //buffer maybe contains some pre-readed datas...
  //if fsock.LineBuffer <> '' then
  //b/egin
  //  buf := fsock.RecvPacket(timeout);
  //  if fsock.LastError <> 0 then
  //    Exit;
  //  dsock.SendString(buf);
  //end;
  //begin relaying of TCP
  ql := TList.Create;
  rl := Tlist.create;
  try
    TimeV.tv_usec := (Timeout mod 1000) * 1000;
    TimeV.tv_sec := Timeout div 1000;
    TimeVal := @TimeV;
    if Timeout = -1 then
      TimeVal := nil;
    FD_ZERO(FDSetSave);
    FD_SET(fsock.Socket, FDSetSave);
    FD_SET(dsock.Socket, FDSetSave);
    FDSet := FDSetSave;
    while synsock.Select(65535, @FDSet, nil, nil, TimeVal) > 0 do
    begin
      rl.clear;
      if FD_ISSET(fsock.Socket, FDSet) then
        rl.Add(fsock);
      if FD_ISSET(dsock.Socket, FDSet) then
        rl.Add(dsock);
      for n := 0 to rl.Count - 1 do
      begin
        fgsock := TTCPBlockSocket(rl[n]);
        if fgsock = fsock then
          dgsock := dsock
        else
          dgsock := fsock;
        if fgsock.WaitingData > 0 then
        begin
          buf := fgsock.RecvPacket(0);
          dgsock.SendString(buf);
          if dgsock.LastError <> 0 then
            exit;
          if dgsock = dsock then
            Inc(WriteCount, Length(buf))
          else
            Inc(ReadCount, Length(buf));
        end
        else
          exit;
      end;
      FDSet := FDSetSave;
    end;
  finally
    rl.free;
    ql.free;
  end;
  result := true;
end;

end.
